{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}

{-
  Copyright 2020 The CodeWorld Authors. All Rights Reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module Blockly.DesignBlock
  ( Type (..),
    FieldType (..),
    BlockType (..),
    Input (..),
    Field (..),
    Inline (..),
    Connection (..),
    DesignBlock (..),
    Color (..),
    Tooltip (..),
    setBlockType,
  )
where

import Blockly.Block as B
import qualified Blockly.TypeExpr as TE
import Control.Monad
import Data.JSString.Text
import Data.List (maximumBy)
import Data.List (intercalate)
import Data.Maybe (fromJust)
import Data.Monoid
import Data.Ord (comparing)
import qualified Data.Text as T
import GHCJS.Foreign hiding (Function, Number, String)
import GHCJS.Foreign.Callback
import GHCJS.Marshal
import GHCJS.Types
import qualified JavaScript.Array as JA

pack = textToJSString

unpack = textFromJSString

-- Low level bindings to construction of various different type of Blockly
-- blocks

data ADT
  = Product String [Type]
  | Sum [ADT]

data User = User String ADT

instance Show User where
  show (User name adt) = name

data Type
  = Arrow [Type]
  | Number
  | Str -- Actually Text
  | Truth
  | Picture
  | Col -- Actually Color
  | List Type -- Have to define kinded types
  | Custom User
  | Poly T.Text
  | Program -- For top level blocks
  | Comment

instance Show Type where
  show Number = "Number"
  show Picture = "Picture"
  show (Custom (User name adt)) = name
  show (Poly c) = T.unpack c
  show (Str) = "Text"
  show (Truth) = "Truth"
  show (Col) = "Color"
  show (Comment) = ""
  show (Program) = "Program"
  show (Arrow tps) = intercalate " -> " $ map show tps
  show (List tp) = "[" ++ show tp ++ "]"

data FieldType = LeftField | RightField | CentreField

data Input
  = Value T.Text [Field]
  | --            | Statement T.Text [Field] Type
    Dummy [Field]

data Field
  = Text T.Text
  | TextE T.Text -- Emphasized Text, for titles
  | TextInput T.Text T.Text -- displayname, value
  | FieldImage T.Text Int Int -- src, width, height

data Connection = TopCon | BotCon | TopBotCon | LeftCon

newtype Inline = Inline Bool

-- Name functionName inputs connectiontype color outputType tooltip
-- name funcName
data BlockType
  = Literal T.Text
  | Function T.Text [Type]
  | Top T.Text [Type]
  | None -- do nothing !
  -- DesignBlock name type inputs isInline Color Tooltip

data DesignBlock = DesignBlock T.Text BlockType [Input] Inline Color Tooltip

newtype Color = Color Int

newtype Tooltip = Tooltip T.Text

fieldCode :: FieldInput -> Field -> IO FieldInput
fieldCode field (Text str) = js_appendTextField field (pack str)
fieldCode field (TextE str) = js_appendTextFieldEmph field (pack str)
fieldCode field (TextInput text name) = js_appendTextInputField field (pack text) (pack name)
fieldCode field (FieldImage src width height) = js_appendFieldImage field (pack src) width height

inputCode :: Bool -> Block -> Input -> IO ()
inputCode rightAlign block (Dummy fields) = do
  fieldInput <- js_appendDummyInput block
  when rightAlign $ js_setAlignRight fieldInput
  foldr
    ( \field fi -> do
        fi_ <- fi
        fieldCode fi_ field
    )
    (return fieldInput)
    fields
  return ()
inputCode rightAlign block (Value name fields) = do
  fieldInput <- js_appendValueInput block (pack name)
  when rightAlign $ js_setAlignRight fieldInput
  foldr
    ( \field fi -> do
        fi_ <- fi
        fieldCode fi_ field
    )
    (return fieldInput)
    fields
  return ()

typeToTypeExpr :: Type -> TE.Type_
typeToTypeExpr (Poly a) = TE.createType $ TE.TypeVar a
typeToTypeExpr t = TE.createType $ TE.Lit (T.pack $ show t) [] -- Currently still a hack

-- set block
setBlockType :: DesignBlock -> IO ()
setBlockType (DesignBlock name blockType inputs (Inline inline) (Color color) (Tooltip tooltip)) = do
  cb <-
    syncCallback1
      ContinueAsync
      ( \this -> do
          let block = B.Block this
          js_setColor block color
          forM_ (zip inputs (False : repeat True)) $ \(inp, rightAlign) -> do
            inputCode rightAlign block inp
          case blockType of
            None -> js_disableOutput block
            Top _ _ -> js_disableOutput block
            _ -> js_enableOutput block
          assignBlockType block blockType
          when inline $ js_setInputsInline block True
          return ()
      )
  js_setGenFunction (pack name) cb

typeToType :: Type -> TE.Type
typeToType (Poly a) = TE.TypeVar a
typeToType (List tp) = TE.Lit (T.pack "list") [typeToType tp]
typeToType lit = TE.Lit (T.pack $ show lit) []

assignBlockType :: Block -> BlockType -> IO ()
assignBlockType block (Literal name) = B.setAsLiteral block name
assignBlockType block (Function name tps) = do
  js_defineFunction (pack name) (TE.fromList tp)
  B.setAsFunction block name
  where
    tp = map typeToType tps
assignBlockType block (Top name tps) = assignBlockType block (Function name tps)
assignBlockType _ _ = return ()

newtype FieldInput = FieldInput JSVal

-- setArrows :: Block -> [Type] -> IO ()
-- setArrows block tps = js_setArrows block typeExprs
--   where
--     typeExprs = TE.toJSArray $ map typeToTypeExpr tps

#ifdef ghcjs_HOST_OS

foreign import javascript unsafe "Blockly.Blocks[$1] = { init: function() { $2(this); }}"
  js_setGenFunction :: JSString -> Callback a -> IO ()

foreign import javascript unsafe "$1.setColour($2)"
  js_setColor :: Block -> Int -> IO ()

foreign import javascript unsafe "$1.setOutput(true)"
  js_enableOutput :: Block -> IO ()

foreign import javascript unsafe "$1.setOutput(false)"
  js_disableOutput:: Block -> IO ()

foreign import javascript unsafe "$1.setTooltip($2)"
  js_setTooltip :: Block -> JSString -> IO ()

foreign import javascript unsafe "$1.appendDummyInput()"
  js_appendDummyInput :: Block -> IO FieldInput

foreign import javascript unsafe "Blockly.TypeInf.defineFunction($1, $2)"
  js_defineFunction :: JSString -> TE.Type_ -> IO ()

foreign import javascript unsafe "$1.appendValueInput($2)"
  js_appendValueInput :: Block -> JSString -> IO FieldInput

foreign import javascript unsafe "$1.appendField($2)"
  js_appendTextField :: FieldInput -> JSString -> IO FieldInput

foreign import javascript unsafe "$1.appendField(new Blockly.FieldLabel($2, 'blocklyTextEmph'))"
  js_appendTextFieldEmph :: FieldInput -> JSString -> IO FieldInput

foreign import javascript unsafe "$1.appendField(new Blockly.FieldImage($2, $3, $4))"
  js_appendFieldImage:: FieldInput -> JSString -> Int -> Int -> IO FieldInput

foreign import javascript unsafe "$1.appendField(new Blockly.FieldTextInput($2), $3)"
  js_appendTextInputField :: FieldInput -> JSString -> JSString -> IO FieldInput

foreign import javascript unsafe "$1.setCheck($2)"
  js_setCheck :: FieldInput -> JSString -> IO ()

foreign import javascript unsafe "$1.setAlign(Blockly.ALIGN_RIGHT)"
  js_setAlignRight :: FieldInput -> IO ()

foreign import javascript unsafe "$1.setInputsInline($2)"
  js_setInputsInline :: Block -> Bool -> IO ()

#else

js_setGenFunction :: JSString -> Callback a -> IO ()
js_setGenFunction = error "GHCJS required"

js_setColor :: Block -> Int -> IO ()
js_setColor = error "GHCJS required"

js_enableOutput :: Block -> IO ()
js_enableOutput = error "GHCJS required"

js_disableOutput:: Block -> IO ()
js_disableOutput = error "GHCJS required"

js_setTooltip :: Block -> JSString -> IO ()
js_setTooltip = error "GHCJS required"

js_appendDummyInput :: Block -> IO FieldInput
js_appendDummyInput = error "GHCJS required"

js_defineFunction :: JSString -> TE.Type_ -> IO ()
js_defineFunction = error "GHCJS required"

js_appendValueInput :: Block -> JSString -> IO FieldInput
js_appendValueInput = error "GHCJS required"

js_appendTextField :: FieldInput -> JSString -> IO FieldInput
js_appendTextField = error "GHCJS required"

js_appendTextFieldEmph :: FieldInput -> JSString -> IO FieldInput
js_appendTextFieldEmph = error "GHCJS required"

js_appendFieldImage:: FieldInput -> JSString -> Int -> Int -> IO FieldInput
js_appendFieldImage = error "GHCJS required"

js_appendTextInputField :: FieldInput -> JSString -> JSString -> IO FieldInput
js_appendTextInputField = error "GHCJS required"

js_setCheck :: FieldInput -> JSString -> IO ()
js_setCheck = error "GHCJS required"

js_setAlignRight :: FieldInput -> IO ()
js_setAlignRight = error "GHCJS required"

js_setInputsInline :: Block -> Bool -> IO ()
js_setInputsInline = error "GHCJS required"

#endif
